VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CStatusBar32x"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

 
Private hIcons(4) As Long 'Hold Icon Images so we don't have to keep hitting the harddrive
Private Declare Function InitCommonControlsEx Lib "Comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DrawIconEx& Lib "user32" (ByVal hdc As Long, ByVal xleft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long)
Private Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, _
ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wcmd As Long) As Long
Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function apiGetWindowDC& Lib "user32" Alias "GetWindowDC" (ByVal hwnd As Long)
Private Declare Function apiGetDC& Lib "user32" Alias "GetDC" (ByVal hwnd As Long)
Private Declare Function SendStringMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function CreateWindowEX Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private StatBarWnd As Long
Private Const ICC_BAR_CLASSES = &H4
Private Const DI_NORMAL = 3
 
 
 
Public Enum sbAlignment
Left = 1
CENTER = 2
Right = 3
End Enum
 
Private Type tagInitCommonControlsEx
    lngSize As Long
    lngICC As Long
End Type
 
  
Const HWND_TOPMOST = -1
Const SW_HIDE = 0
Const SW_SHOWNORMAL = 1
 
Const SWP_SHOWWINDOW = &H40

' Window Color constants
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNTEXT = 18
' Window Style constants
Const WS_VISIBLE = &H10000000
Const WS_CHILD = &H40000000
 
' CreateWindow constants
Const CW_USEDEFAULT = &H80000000
Private Const CCS_NORESIZE = &H4
Private Const WM_PAINT = &HF
Private Const SBARS_SIZEGRIP = &H100
Private Const STATUSCLASSNAMEW = "msctls_statusbar32"
Private Const WM_USER = &H400
Private Const SB_SETTEXTA = (WM_USER + 1)
Private Const SB_SETTEXTW = (WM_USER + 11)
Private Const SB_GETTEXTA = (WM_USER + 2)
Private Const SB_GETTEXTW = (WM_USER + 13)
Private Const SB_GETTEXTLENGTHA = (WM_USER + 3)
Private Const SB_GETTEXTLENGTHW = (WM_USER + 12)
Private Const SB_GETTEXT = SB_GETTEXTW
Private Const SB_SETTEXT = SB_SETTEXTW
Private Const SB_GETTEXTLENGTH = SB_GETTEXTLENGTHW
Private Const SB_SETPARTS = (WM_USER + 4)
Private Const SB_GETPARTS = (WM_USER + 6)
Private Const SB_GETBORDERS = (WM_USER + 7)
Private Const SB_SETMINHEIGHT = (WM_USER + 8)
Private Const SB_SIMPLE = (WM_USER + 9)
Private Const SB_GETRECT = (WM_USER + 10)
Private Const SB_ISSIMPLE = (WM_USER + 14)
Private Const SBT_OWNERDRAW = &H1000
Private Const SBT_NOBORDERS = &H100
Private Const SBT_POPOUT = &H200
Private Const SBT_RTLREADING = &H400
Private Const SBT_STRECH = &H600

 
Dim mfrmParent As Object
 
Public Function GetStatBarHwnd()
GetStatBarHwnd = StatBarWnd
End Function

Public Sub SetIcon(Pane As Integer, IconNum As Integer)
On Error Resume Next
Dim hLarge As Long, Retint As Long
Retint = ExtractIconEx(App.Path & "\ODIcons.dll", IconNum, hLarge, hIcons(Pane), 2)
End Sub

Public Sub UpdateStatBar(Pane As Integer)
Dim l As Long
Dim rc As RECT
  Call SendMessage(StatBarWnd, SB_GETRECT, Pane, rc)
  Call InvalidateRect(StatBarWnd, rc, True)
End Sub

Public Sub DrawTextPic(Pane As Integer, strText As String, Optional IconNum As Integer, _
Optional sbAlignment As sbAlignment = CENTER, Optional TextColor As ColorConstants = vbButtonText, _
Optional fontbold As Boolean = False, Optional textoffset As Integer)
  
Dim hLarge As Long
Dim hSmall As Long
Dim Retint As Long
Dim Rr As Long
Dim k As Long
Dim StatBarDC As Long
Dim CurrentFont As Long, NewFont As Long
Dim PaintBrush As Long, oldbrush As Long
Dim dl As Long
Dim BrushRect As RECT
Dim StatBarRect As RECT
Dim dt As DRAWTEXTPARAMS
Dim lf As LOGFONT
Dim TextAlign As Long
   
   'Make background transparent
    dl = SetBkMode(StatBarDC, 0)
    
   'Fill drawtext params
   dt.cbSize = LenB(dt)
   dt.iTabLength = 0
   dt.iLeftMargin = 0
   dt.iRightMargin = 0
   dt.uiLengthDrawn = 0

   StatBarDC = GetWindowDC(StatBarWnd)

   CurrentFont = SelectObject(StatBarDC, GetStockObject(SYSTEM_FONT))
 
     
   lf.lffacename = "MS Sans Serif" & Chr$(0)
   lf.lfHeight = 12
   If fontbold = True Then
   lf.lfWeight = 650
   Else
   lf.lfWeight = 500
   End If
   dl = SetTextColor(StatBarDC, TextColor)
   
   NewFont = CreateFontIndirect(lf)
   dl = SelectObject(StatBarDC, NewFont)
     
   dl = SetBkMode(StatBarDC, 0)
   
   'Get dimensions of requested pane
   Call SendMessage(StatBarWnd, SB_GETRECT, Pane, StatBarRect)
   
   'Form is sized too small and the pane is not visible then exit
   If StatBarRect.Right - StatBarRect.Left <= 0 Then Exit Sub
   
   PaintBrush = CreateSolidBrush(GetSysColor(15)) 'System Button color
  
   'fill Pane with Brush of System Button Color
   BrushRect.Top = StatBarRect.Top + 2
   BrushRect.Left = StatBarRect.Left + 2
   BrushRect.Right = StatBarRect.Right - 2
   BrushRect.Bottom = StatBarRect.Bottom - 2
   dl = FillRect(StatBarDC, BrushRect, PaintBrush)
      
   If sbAlignment = CENTER Then TextAlign = DT_CENTER
   If sbAlignment = Left Then TextAlign = DT_LEFT
   If sbAlignment = Right Then TextAlign = DT_RIGHT
   
   StatBarRect.Left = StatBarRect.Left + textoffset
   StatBarRect.Right = StatBarRect.Right - 2
   dl = DrawTextEx(StatBarDC, strText, Len(strText), StatBarRect, TextAlign Or DT_VCENTER& Or DT_SINGLELINE Or DT_END_ELLIPSIS Or DT_PATH_ELLIPSIS Or DT_MODIFYSTRING, dt)
   StatBarRect.Right = StatBarRect.Right + 2
   StatBarRect.Left = StatBarRect.Left - textoffset
   
   Retint = DrawIconEx(StatBarDC, StatBarRect.Left + 3, 4, hIcons(Pane), 0, 0, 0, 0, DI_NORMAL)
   'If you would rather use an imagelist
   'Retint = DrawIconEx(StatBarDC, StatBarRect.Left + 3, 3, frmStatusBar.ImageList1.ListImages(1).ExtractIcon, 0, 0, 0, 0, DI_NORMAL)
 
  
  
   'Restore original font
   NewFont = SelectObject(StatBarDC, CurrentFont)
   'Restore original font
   dl = SelectObject(StatBarDC, CurrentFont)
   'And free up GDI objects
   dl = DeleteObject(NewFont)
   dl = DeleteObject(PaintBrush)
 
 
End Sub
Private Sub Class_Initialize()
  Dim iccex As tagInitCommonControlsEx
    With iccex
        .lngSize = LenB(iccex)
        .lngICC = ICC_BAR_CLASSES
    End With
    Call InitCommonControlsEx(iccex)
 
     StatBarWnd = 0 '
End Sub



Public Sub Create()
 
 'Create StatusBar
 StatBarWnd = CreateWindowEX(0&, _
 "msctls_statusbar32", _
 "", _
 WS_CHILD Or WS_VISIBLE Or CCS_NORESIZE, _
  0, 0, Parent.Width, 60, _
 Parent.hwnd, 0&, App.hInstance, vbNull)
 
  
Dim StatusBarPaneSize(4) As Long

StatusBarPaneSize(0) = 100
StatusBarPaneSize(1) = 200
StatusBarPaneSize(2) = 300
StatusBarPaneSize(3) = 400
StatusBarPaneSize(4) = -1

Dim Ret As Long

' tell statusbar about number and size of panes
Ret = SendMessage(StatBarWnd, SB_SETPARTS, 5, StatusBarPaneSize(0))
 
'SBPS_STRETCH
Ret = SendStringMessage(StatBarWnd, SB_SETTEXTA, 0 Or SBT_POPOUT Or SBT_OWNERDRAW, "")
Ret = SendStringMessage(StatBarWnd, SB_SETTEXTA, 1 Or SBT_OWNERDRAW, "")
Ret = SendStringMessage(StatBarWnd, SB_SETTEXTA, 2 Or SBT_OWNERDRAW, "")
Ret = SendStringMessage(StatBarWnd, SB_SETTEXTA, 3 Or SBT_OWNERDRAW, "")
Ret = SendStringMessage(StatBarWnd, SB_SETTEXTA, 4 Or SBT_OWNERDRAW, "")
 
Call ShowWindow(StatBarWnd, SW_SHOWNORMAL)
Call SetParent(StatBarWnd, Parent.hwnd)
 
End Sub
Public Property Get Parent() As Object
    Set Parent = mfrmParent
End Property

Public Property Set Parent(Frm As Object)
    Set mfrmParent = Frm
End Property


Private Sub Class_Terminate()
 Exit Sub
    If StatBarWnd <> 0 Then
        Call DestroyWindow(StatBarWnd)
    End If
End Sub

Public Sub DestroyStatBar()
On Error Resume Next
 
If StatBarWnd <> 0 Then

        Call DestroyWindow(StatBarWnd)
    End If
End Sub

Public Sub Resize()
On Error Resume Next
  Call MoveWindow(StatBarWnd, 0, Parent.Height / Screen.TwipsPerPixelY - 49, Parent.Width / Screen.TwipsPerPixelX - 8, 22, True)
   
 
End Sub
Public Sub SetStatBarText(PaneNumber As Integer, StringToAdd As String)
 Dim Ret As Long
 'If you don't use SBT_OWNERDRAW flag when creating the
 'Statubar, then you would update the pane with this call
 'zero based pane number
 Ret = SendStringMessage(StatBarWnd, SB_SETTEXTA, PaneNumber, StringToAdd)
 Ret = UpdateWindow(StatBarWnd)
End Sub
 

